home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _3565dfcb0260363d48942d185cd2f2ec < prev    next >
Encoding:
Text File  |  2002-05-30  |  2.3 KB  |  123 lines
  1. package Tk::Animation;
  2.  
  3. use vars qw($VERSION);
  4. $VERSION = '3.018'; # $Id: //depot/Tk8/Tk/Animation.pm#18 $
  5.  
  6. use Tk::Photo;
  7. use base  qw(Tk::Photo);
  8.  
  9. Construct Tk::Widget 'Animation';
  10.  
  11. sub MainWindow
  12. {
  13.  return shift->{'_MainWIndow_'};
  14. }
  15.  
  16. sub add_frame
  17. {
  18.  my $obj = shift;
  19.  $obj->{'_frames_'} = [] unless exists $obj->{'_frames_'};
  20.  push(@{$obj->{'_frames_'}},@_);
  21. }
  22.  
  23. sub new
  24. {
  25.  my ($class,$widget,%args) = @_;
  26.  my $obj = $class->SUPER::new($widget,%args);
  27.  $obj->{'_MainWIndow_'} = $widget->MainWindow;
  28.  if ($args{'-format'} eq 'gif')
  29.   {
  30.    my @images;
  31.    local $@;
  32.    while (1)
  33.     {
  34.      my $index = @images;
  35.      $args{'-format'} = "gif -index $index";
  36.      my $img;
  37.      eval {local $SIG{'__DIE__'};  $img = $class->SUPER::new($widget,%args) };
  38.      last if $@;
  39.      push(@images,$img);
  40.     }
  41.    if (@images > 1)
  42.     {
  43.      $obj->add_frame(@images);
  44.      $obj->{'_frame_index_'}  = 0;
  45.     }
  46.   }
  47.  return $obj;
  48. }
  49.  
  50. sub set_image
  51. {
  52.  my ($obj,$index)  = @_;
  53.  my $frames = $obj->{'_frames_'};
  54.  return unless $frames && @$frames;
  55.  $index = 0 unless $index < @$frames;
  56.  $obj->copy($frames->[$index]);
  57.  $obj->{'_frame_index_'} = $index;
  58. }
  59.  
  60. sub next_image
  61. {
  62.  my ($obj)  = @_;
  63.  my $frames = $obj->{'_frames_'};
  64.  return unless $frames && @$frames;
  65.  $obj->set_image((($obj->{'_frame_index_'} || 0)+1) % @$frames);
  66. }
  67.  
  68. sub start_animation
  69. {
  70.  my ($obj,$period) = @_;
  71.  my $frames = $obj->{'_frames_'};
  72.  return unless $frames && @$frames;
  73.  my $w = $obj->MainWindow;
  74.  $obj->stop_animation;
  75.  $obj->{'_NextId_'} = $w->repeat($period,[$obj,'next_image']);
  76. }
  77.  
  78. sub stop_animation
  79. {
  80.  my ($obj) = @_;
  81.  my $id = delete $obj->{'_NextId_'};
  82.  Tk::catch { $id->cancel } if $id;
  83.  $obj->set_image(0);
  84. }
  85.  
  86. 1;
  87. __END__
  88.  
  89. =cut
  90.  
  91. #
  92. # This almost works for changing the animation on the fly
  93. # but does not resize things correctly
  94. #
  95.  
  96. sub gif_sequence
  97. {
  98.  my ($obj,%args) = @_;
  99.  my $widget = $obj->MainWindow;
  100.  my @images;
  101.  local $@;
  102.  while (1)
  103.   {
  104.    my $index = @images;
  105.    $args{'-format'} = "gif -index $index";
  106.    my $img;
  107.    eval
  108.     {local $SIG{'__DIE__'};
  109.      my $img = $widget->Photo(%args);
  110.      push(@images,$img);
  111.     };
  112.    last if $@;
  113.   }
  114.  if (@images)
  115.   {
  116.    delete $obj->{'_frames_'};
  117.    $obj->add_frame(@images);
  118.    $obj->configure(-width => 0, -height => 0);
  119.    $obj->set_frame(0);
  120.   }
  121. }
  122.  
  123.